(defpackage :util
  (:use :cl)
  (:shadow :max :min)
  (:nicknames :u)
  (:export :with-gensyms
           :nl
           :sharp-dot
           :string2
           :random-elt
           :remove-nth
           :delete-nth
           :randomize-list
           :concat
           :neq
           :neql
           :nequal
           :nequalp
           :half
           :edit-string
           :last1
           :flatten
           :slurp-lisp-file
           :slurp-lines
           :collect-if
           :collect-with
           :curry
           :middle
           :bubble-sort
           :subst-tree
           :funcallable
           :shuttle-bits
           :while
           :stream-discard-input
           :let-if
           :let*-if
           :list-slots
           :simple-list-slots
           :simple-list-slots-except-nil
           :copy-slots
           :simple-copy-slots
           :symbol-capitalize
           :most
           :average
           :distance
           :distance-*
           :copy
           :max
           :min
           :popn
           :dump-object
           :plist-compare
           :hash-to-plist
           :plist-to-hash))

(in-package :util)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro with-gensyms ((&rest syms) &body body)
    `(let ,(loop for var in syms collect `(,var (gensym ,(symbol-name var))))
       ,@body)))

(defun nl (&optional (string ""))
  "Add a newline to the end of a string."
  (concatenate 'string string (string #\Newline)))

(defclass sharp-dot-trick ()
  ((obj :initarg :obj :accessor sharp-dot-trick-obj)))

(defmethod print-object ((obj sharp-dot-trick) stream)
  (format stream "#.~s" (sharp-dot-trick-obj obj)))

(defun sharp-dot (obj)
  (make-instance 'sharp-dot-trick :obj obj))

(defun string2 (object)
  "return OBJECT as a string unless it is already a string."
  (if (stringp object)
      object
      (prin1-to-string object)))

(defun random-elt (list)
  (elt list (mt19937:random (length list))))

(defun remove-nth (list n)
  (append (subseq list 0 n)
         (subseq list (1+ n))))

(defun delete-nth (list n)
  (assert (< -1 n (length list)))
  (if (zerop n)
      (cdr list)
      (progn
        (setf (cdr (nthcdr (1- n) list)) (nthcdr (1+ n) list))
        list)))

(defun randomize-list (list)
  (setf list (copy-list list))
  (loop for i below (length list)
        for r = (mt19937:random (length list))
        collect (prog1
                    (elt list r)
                  (setf list (delete-nth list r)))))

(defun concat (&rest strings)
  (apply 'concatenate 'string (mapcar 'string strings)))

(defun neq (a b)
  (not (eq a b)))

(defun neql (a b)
  (not (eql a b)))

(defun nequal (a b)
  (not (equal a b)))

(defun nequalp (a b)
  (not (equalp a b)))

(defun half (a)
  (truncate a 2))

(defun edit-string (string ch)
  "CH is a character that will either delete the last character if its
a backspace or append to the end of STRING. The new string is returned."
  (case ch
    (#\Backspace
     (when (plusp (length string))
       (subseq string 0 (1- (length string)))))
    (t (concatenate 'string string (string ch)))))

(defun last1 (list)
  (car (last list)))

(defun flatten (tree)
  "Turn the tree into a list."
  (if (atom tree)
      (list tree)
      (mapcan 'flatten tree)))

(defmacro mapcar-if ((var list) &body body)
  `(loop for ,var in ,list
         when (progn ,@body)
           collect var))

(defun slurp-lisp-file (file &optional (package *package*))
  "Returns a list of all SEXPs read from FILE."
  (let ((*package* package))
    (with-open-file (stream file)
      (loop for line = (read stream nil stream)
            until (eq line stream)
            collect line))))

(defun slurp-lines (file)
  (with-open-file (stream file)
    (loop for line = (read-line stream nil stream)
          until (eq line stream)
          collect line)))

(defun collect-if (fn list &key (key 'identity))
  (loop for i in list
        when (funcall fn (funcall key i))
          collect i))

(defmacro collect-with ((item list &rest keys &key &allow-other-keys) &body body)
  `(collect-if (lambda (,item) ,@body)
               ,list ,@keys))

(defmacro curry (function &rest args)
  "If the arg(s) are in parens then they're needed. if not then
they're already supplied. The order of the args is preserved and
passed to FUNCTION. Example:

 (curry list first (second) third (fourth fifth)
 <=>
 (lambda (second fourth fifth) (list first second third fourth fifth))"
  (loop
    for i in args
    append (if (and (listp i) (not (null i))) i (list i)) into arg-list
    if (listp i)
      append i into needed
    ;;else append (list i) into supplied
    finally (return `(lambda (,@needed) (,function ,@arg-list)))))

(defun middle (list)
  "Return the middle element of LIST."
  (nth (half (length list)) list))

(defun bubble-sort (list fn)
  "A dumb sort algorithm. It's slow and why is it in here anyway?"
  (if (> (length list) 1)
      (loop while
            (loop for i from (1- (length list)) downto 1
                  with swap = nil
                  when (funcall fn (elt list i) (elt list (1- i)))
                    do (psetf (elt list i) (elt list (1- i))
                              (elt list (1- i)) (elt list i)
                              swap t)
                  finally (return swap))
            finally (return list))
      list))

(defun funcallable (thing)
  "Return T if you can use funcall on thing."
  (or (and (symbolp thing)
           (fboundp thing))
      (functionp thing)))

(defun subst-tree (old new tree &key (test 'eql))
  "Walk the tree and anywhere OLD is found or if OLD is a function,
anywhere it returns T then call use NEW or if NEW is a function use
its return value."
  (labels ((walk (list)
             (cond
               ((if (funcallable old)
                    (funcall old list)
                    (funcall test list old))
                (if (funcallable new)
                    (funcall new list)
                    new))
               ((atom list)
                list)
               (t
                (mapcar #'walk list)))))
    (walk tree)))

(defun shuttle-bits (from-stream to-stream &optional (buffer-size (* 1024 10)))
;; (assert (equal (stream-element-type from-stream) (stream-element-type to-stream)))
  (let ((seq (make-array buffer-size :element-type (stream-element-type from-stream))))
    (loop for items = (read-sequence seq from-stream) do
      ;;          (when (< items 200)
      ;;            (print (map 'string 'code-char (subseq seq 0 items))))
      (write-sequence seq to-stream :end items)
          sum items into sum
          while (= items buffer-size)
          finally (return sum))))

(defmacro while (test &body body)
  `(loop while ,test do (progn ,@body)))

(defun stream-discard-input (stream &optional (discard-to *standard-output*))
  (handler-case
      (while (listen stream)
        (let ((ch (code-char (read-byte stream))))
          (write-char (if (char= ch (code-char 13))
                          #\Newline ch)
                      discard-to)))
    (end-of-file ()
      nil)))

(defmacro let-if ((symbol expression) &body body)
  "if expression is non-NIL, bind EXPRESSION's value to SYMBOL and execute
body. Do nothing otherwise."
  `(let ((,symbol ,expression))
     (when ,symbol ,@body)))

(defmacro let*-if ((&rest bindings) &body body)
  "Each element in BINDINGS is a (symbol expression) pair. If all expressions are non-NIL then bind them all to their symbols and execute BODY."
  (cond
    ((cdr bindings)
     `(let-if ,(car bindings) (let*-if ,(cdr bindings) ,@body)))
    (bindings
     `(let-if ,(car bindings) ,@body))
    (t nil)))

(defgeneric list-slots (class)
  (:method-combination append :most-specific-last)
  (:documentation "List all slots in a class as a plist"))

#-(or lispworks ccl sbcl allegro)
(defmacro with-slot-initarg ((class slot initarg) &body body)
  (error "unimplemented"))

#+lispworks
(defmacro with-slot-initarg ((class slot initarg) &body body)
  (with-gensyms (dfn)
    `(let* ((,dfn (find ,slot (clos:class-slots (class-of ,class))
                        :key 'clos:slot-definition-name))
            (,initarg (first (clos:slot-definition-initargs ,dfn))))
       (check-type (clos:slot-definition-initargs ,dfn) cons)
       ,@body)))

#+ccl
(defmacro with-slot-initarg ((class slot initarg) &body body)
  (with-gensyms (dfn)
    `(let* ((,dfn (find ,slot (ccl:class-slots (class-of ,class))
                        :key 'ccl:slot-definition-name))
            (,initarg (first (ccl:slot-definition-initargs ,dfn))))
       (check-type (ccl:slot-definition-initargs ,dfn) cons)
       ,@body)))

#+sbcl
(defmacro with-slot-initarg ((class slot initarg) &body body)
  (with-gensyms (dfn)
    `(let* ((,dfn (find ,slot (sb-mop:class-slots (class-of ,class))
                        :key 'sb-mop:slot-definition-name))
            (,initarg (first (sb-mop:slot-definition-initargs ,dfn))))
       (check-type (sb-mop:slot-definition-initargs ,dfn) cons)
       ,@body)))

#+allegro
(defmacro with-slot-initarg ((class slot initarg) &body body)
  (with-gensyms (dfn)
    `(let* ((,dfn (find ,slot (mop:class-slots (class-of ,class))
                        :key 'mop:slot-definition-name))
            (,initarg (first (mop:slot-definition-initargs ,dfn))))
       (check-type (mop:slot-definition-initargs ,dfn) cons)
       ,@body)))

(defun simple-list-slots (class &rest slots)
  (mapcan (lambda (s)
            (with-slot-initarg (class s initarg)
              (list initarg
                    (slot-value class s))))
          slots))

(defun simple-list-slots-except-nil (class &rest slots)
  (mapcan (lambda (s)
            (with-slot-initarg (class s initarg)
              (when (slot-value class s)
                (list initarg
                      (slot-value class s)))))
          slots))

(defgeneric copy-slots (from to)
  (:method-combination progn :most-specific-last)
  (:documentation "Copy the slots in FROM to the instance TO."))

(defmethod copy-slots progn ((from standard-class) (to standard-class))
  "By default do nuthin.")

(defun simple-copy-slots (from to &rest slots)
  (dolist (i slots)
    (when (slot-boundp from i)
      (setf (slot-value to i) (slot-value from i)))))

(defun symbol-capitalize (sym)
    (substitute #\Space #\- (string-capitalize sym)))

(defun most (list fn &key (key 'identity))
  "Find the element in list that is the most X, where fn defines what
X is. Biggest, smallest, etc. Equivalent to (first (sort (copy-list list) fn :key key))."
  (when list
    (loop for i in list
          for v = (funcall key i)
          with mosti = (first list)
          with mostv = (funcall key mosti)
          when (funcall fn v mostv)
            do (setf mosti i mostv v)
          finally (return mosti))))

(defun average (&rest numbers)
  (/ (reduce '+ numbers)
     (length numbers)))

(defun distance-* (x1 y1 x2 y2)
  (let ((xrel (- x2 x1))
        (yrel (- y2 y1)))
    (sqrt (+ (expt xrel 2) (expt yrel 2)))))

(defun distance (p1 p2)
  (distance-* (first p1) (second p1) (first p2) (second p2)))

(defgeneric copy (obj))

(defmethod copy (obj)
  (let ((new (make-instance (type-of obj))))
    (copy-slots obj new)
    new))

(defun max (&rest args)
  (loop for i in args
        maximize i))

(defun min (&rest args)
  (loop for i in args
        minimize i))

(defmacro popn (n place)
  `(prog2
       (assert (<= ,n (length ,place))
               ()
               "Cannot pop ~d elements. Only ~d remaining." ,n (length ,place))
       (subseq ,place 0 ,n)
     (setf ,place (nthcdr ,n ,place))))

(defgeneric dump-object (object)
  (:method-combination append :most-specific-last))

(defmethod dump-object append (object)
  (list (type-of object)))

(defun plist-compare (plist1 plist2 &key (test 'eq))
  (and (= (length plist1)
          (length plist2))
       (loop for rest = plist1
               then (cddr rest)
             while rest
             for key = (first rest)
             for value = (second rest)
             always (and (get-properties plist2 (list key))
                         (funcall test
                                  (getf plist2 key)
                                  value)))))

(defun hash-to-plist (hash)
  (let ((acc (list)))
    (maphash (lambda (k v)
               (setf (getf acc k) v))
             hash)
    acc))

(defun plist-to-hash (plist)
  (let ((hash (make-hash-table)))
    (loop for i = plist then (cddr i)
          while i
          for k = (first i)
          for v = (second i)
          do (setf (gethash k hash) v))
    hash))
